home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programmer's Power Pack / Delphi Volume 1.iso / s_to_z / tcontain / tcontain.pas next >
Pascal/Delphi Source File  |  1996-09-15  |  18KB  |  657 lines
  1. Unit tContain;
  2. (**************************************************)
  3. (* tObjectList is taken largely from BI's RTL     *)
  4. (* modified to use & free tObjects and added      *)
  5. (* persistant stream support &                    *)
  6. (* emulation of BP7's tCollection iteration       *)
  7. (* support with ForEach,FirstThat & LastThat      *)
  8. (*                                                *)
  9. (* This container class assumes all items are     *)
  10. (* derived from tObject                           *)
  11. (* Limit is still MaxListSize items, for now..    *)
  12. (**************************************************)
  13. (*    95/05   LPL Soft inc                        *)
  14. (**************************************************)
  15. {*********  Parts from  ****************************}
  16. {                                                  }
  17. {  Delphi Visual Component Library                 }
  18. {                                                  }
  19. {  Copyright (c) 1995 Borland International        }
  20. {                                                  }
  21. {**************************************************}
  22. (* Send bug reports (with reproducable source)    *)
  23. (*    LPL Soft : Robert Daignault                 *)
  24. (*    Compuserve: 70302,1653                      *)
  25. (*                                                *)
  26. (* Note : This unit is still in Beta version. Use *)
  27. (*        at your own risk!                       *)
  28. (**************************************************)
  29.                   interface
  30. (**************************************************)
  31. Uses Classes, SysUtils;
  32. type
  33.  pObjects = ^tObjects;
  34.  TObjects = array[0..MaxListSize - 1] of pointer{tObject};
  35.  
  36.  TObjectList = class(TPersistent)
  37.   private
  38.     FDestroy : Boolean;
  39.     FList    : pObjects;
  40.     FCount   : Integer;
  41.     FCapacity: Integer;
  42.  
  43.     (*****************) protected {procedures *****************}
  44.     procedure Error; virtual;
  45.     procedure Grow; virtual;
  46.     procedure Put(Index: Integer; Item: tObject);
  47.     function  Get(Index: Integer): tObject;
  48.     procedure SetCapacity(NewCapacity: Integer);
  49.     procedure SetCount(NewCount: Integer);
  50.     Function  Allocate(Size:LongInt):Pointer;
  51.     Procedure FreeItem(AnItem:Pointer); virtual;
  52.     (*****************) Public {procedures *****************}
  53.     Constructor Create;
  54.     Constructor CreateWithOptions(DestroyObjects:Boolean; InitialCapacity:Integer);
  55.     destructor  Destroy; override;
  56.  
  57.     function    AddObject(Item: tObject): Integer; virtual;
  58.  
  59.     (* Clear and Delete are identical. They do not Free each object *)
  60.     procedure   Clear; virtual;
  61.     procedure   Delete(Index: Integer);
  62.     Procedure   DeleteAll;
  63.  
  64.     (* Free procedures first destroy tObjects and then call Delete procedures*)
  65.     Procedure   FreeAll;
  66.     Procedure   FreeAt(Index:Integer);
  67.     Procedure   FreeObject(Item: tObject);
  68.  
  69.     function    IndexOf(Item: tObject): Integer;
  70.     procedure   Insert(Index: Integer; Item: tObject); virtual;
  71.     procedure   Move(CurIndex, NewIndex: Integer);
  72.     procedure   Pack;
  73.  
  74.     (***************** Streaming support *****************)
  75.     Constructor CreateFromStream(const FileName: string);
  76.  
  77.     Procedure   SaveToStream(const FileName:String);
  78.     procedure   LoadFromStream(const FileName: string);
  79.     procedure   ReadData(S: TStream); virtual;
  80.     procedure   WriteData(S: TStream); virtual;
  81.     procedure   DefineProperties(Filer: TFiler); override;
  82.  
  83.  
  84.     (***************** Iteration procedures **************)
  85.     function    First: tObject; virtual;
  86.     function    Last: tObject; virtual;
  87.     Function    Next(Item:tObject; Forward:Boolean):tObject; virtual;
  88.  
  89.          (* Action will be called Count times, each with*)
  90.          (* one of its contained tObject                *)
  91.     (* Procedure Action(AnObject:YourClass); far; *)
  92.     procedure   ForEach(Action: Pointer);
  93.  
  94.     (* Function Test(AnObject:YourClass):Boolean; far; *)
  95.     function    LastThat(Test: Pointer): tObject;
  96.     function    FirstThat(Test: Pointer): tObject;
  97.  
  98.  
  99.    (*           ForEach, FirstThat and LastThat iterators
  100.           These work exactly like BP7's tCollection methods.
  101.  
  102.               These methods will call their Action or test
  103.              parameters for each tObject it contains.
  104.              All Iterators assume that Action and test are
  105.              <embedded procedures> or functions declared with
  106.              the far attribute. Forgetting to put the far
  107.              attribute will cause a GPF. Note that there is
  108.              no type checking done by the compiler on either
  109.              the procedure type or the parameters to Test and
  110.              Action.
  111.    *)
  112.  
  113.          (* FirstThat and LastThat stop the iteration when Test *)
  114.          (* returns TRUE.These functions return the object that *)
  115.          (* caused the iteration to stop. The differ only in the*)
  116.          (* Iteration order. LastThat processes the list in     *)
  117.          (* reverse order                                       *)
  118.  
  119.     (*****************  Properties  **************)
  120.     property    Capacity: Integer read FCapacity write SetCapacity;
  121.     property    Items[Index: Integer]: tObject read Get write Put; default;
  122.     property    Count:Integer read FCount;
  123.     Property    DestroyObjects:Boolean read FDestroy write FDestroy;
  124.   end;
  125.  
  126.              (* Streaming registration support *)
  127. Procedure  RegisterClass(const LoadProc,StoreProc:Pointer;Sender:tClass);
  128. Function   IsRegistered(AClass:tClass):Boolean;
  129. (**************************************************************************)
  130.                               implementation
  131. (**************************************************************************)
  132. Uses Consts;
  133.  
  134. type
  135.  tClassName=String[63];
  136.  
  137.  tRegisterRec=Class(tObject)
  138.   Obj:tClass; (* Class type *)
  139.   DoLoad,
  140.   DoStore :Pointer{TStreamProc}; (* This is a pointer because otherwise
  141.                               a class instance would be required to register*)
  142.   Constructor Create(AClass:tClass; Loader,Storer:Pointer);
  143.  end;
  144.  
  145. var ClassRegistry:tStringList;
  146. (**************************************************************************)
  147. Constructor tRegisterRec.Create(AClass:tClass; Loader,Storer:Pointer);
  148. begin
  149.  Inherited Create;
  150.  Obj:=AClass;
  151.  DoLoad:=Loader;
  152.  DoStore:=Storer;
  153. end;
  154.  
  155. (**************************************************************************)
  156. Procedure RegisterClass(const LoadProc,StoreProc:Pointer;Sender:tClass);
  157. begin
  158.  ClassRegistry.AddObject(Sender.ClassName,
  159.                          tRegisterRec.Create(Sender,LoadProc,StoreProc));
  160. end;
  161.  
  162. Function  IsRegistered(AClass:tClass):Boolean;
  163. Var Index:Integer;
  164. begin
  165.  Result:=ClassRegistry.Find(AClass.ClassName,Index);
  166. end;
  167.  
  168. (**************************************************************************)
  169. Function   GetRegistration(AName:tClassName):tRegisterRec;
  170. Var Index:Integer;
  171. begin
  172.  With ClassRegistry do
  173.   If Find(AName,Index)
  174.    then Result:=tRegisterRec(Objects[Index])
  175.    else Result:=Nil;
  176. end;
  177.  
  178. Function   CreateInstanceByName(const Name:tClassName;Var Loader:Pointer):tObject;
  179. Var R:tRegisterRec;
  180.     S:String[63];
  181. begin
  182.  Result:=Nil;
  183.  R:=GetRegistration(Name);
  184.  If R<>Nil
  185.   then begin
  186.    Result:=R.Obj.Create;
  187.    Loader:=R.DoLoad;
  188.   end
  189.   else Raise EClassNotFound.CreateFmt('Class <%s> not registered',[Name]);
  190. end;
  191.  
  192.  
  193. (**************************************************************************)
  194. Constructor tObjectList.Create;
  195. begin
  196.  Inherited Create;
  197.  FCount:=0;
  198.  FCapacity:=0;
  199.  FDestroy:=True;
  200. end;
  201.  
  202. Constructor tObjectList.CreateWithOptions(DestroyObjects:Boolean; InitialCapacity:Integer);
  203. begin
  204.  Create;
  205.  FDestroy:=DestroyObjects;
  206.  SetCapacity(InitialCapacity);
  207. end;
  208.  
  209. Constructor tObjectList.CreateFromStream(const FileName: string);
  210. begin
  211.  Create;
  212.  LoadFromStream(FileName);
  213. end;
  214.  
  215. destructor tObjectList.Destroy;
  216. begin
  217.  FreeAll;
  218.  Clear;
  219.  Inherited Destroy;
  220. end;
  221.  
  222. function tObjectList.AddObject(Item: tObject): Integer;
  223. begin
  224.  Result := FCount;
  225.  if Result = FCapacity
  226.   then Grow;
  227.  FList^[Result] := Item;
  228.  Inc(FCount);
  229. end;
  230.  
  231. (*************************